home *** CD-ROM | disk | FTP | other *** search
/ PC Open 105 / PC Open 105 CD 1.bin / CD1 / INTERNET / COPIA SITI / Getleft / getleft-setup-notcl.exe / {app} / scripts / mwUtil.tcl < prev    next >
Encoding:
Text File  |  2003-12-28  |  11.1 KB  |  421 lines
  1. #==============================================================================
  2. # Contains utility procedures for mega-widgets.
  3. #
  4. # Structure of the module:
  5. #   - Namespace initialization
  6. #   - Public utility procedures
  7. #
  8. # Copyright (c) 2000-2004  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
  9. #==============================================================================
  10.  
  11. package require Tcl 8
  12. package require Tk  8
  13.  
  14. #
  15. # Namespace initialization
  16. # ========================
  17. #
  18.  
  19. namespace eval mwutil {
  20.     #
  21.     # Public variables:
  22.     #
  23.     variable version    1.7
  24.     variable library    [file dirname [info script]]
  25.  
  26.     #
  27.     # Public procedures:
  28.     #
  29.     namespace export    wrongNumArgs defineKeyNav generateEvent \
  30.             configure fullConfigOpt fullOpt enumOpts \
  31.             setConfigVals configSubCmd attribSubCmd 
  32. }
  33.  
  34. #
  35. # Public utility procedures
  36. # =========================
  37. #
  38.  
  39. #------------------------------------------------------------------------------
  40. # mwutil::wrongNumArgs
  41. #
  42. # Generates a "wrong # args" error message.
  43. #------------------------------------------------------------------------------
  44. proc mwutil::wrongNumArgs args {
  45.     set optList {}
  46.     foreach arg $args {
  47.     lappend optList \"$arg\"
  48.     }
  49.     return -code error "wrong # args: should be [enumOpts $optList]"
  50. }
  51.  
  52. #------------------------------------------------------------------------------
  53. # mwutil::defineKeyNav
  54. #
  55. # For a given mega-widget class, the procedure defines the binding tag
  56. # ${class}KeyNav as a partial replacement for "all", by substituting the
  57. # scripts bound to the events <Key-Tab>, <Shift-Key-Tab>, and <<PrevWindow>>
  58. # with new ones which propagate these events to the mega-widget of the given
  59. # class containing the widget to which the event was reported.  (The event
  60. # <Shift-Key-Tab> was replaced with <<PrevWindow>> in Tk 8.3.0.)  This tag is
  61. # designed to be inserted before "all" in the list of binding tags of a
  62. # descendant of a mega-widget of the specified class.
  63. #------------------------------------------------------------------------------
  64. proc mwutil::defineKeyNav class {
  65.     foreach event {<Key-Tab> <Shift-Key-Tab> <<PrevWindow>>} {
  66.     bind ${class}KeyNav $event \
  67.          [list mwutil::generateEvent %W $class $event]
  68.     }
  69. }
  70.  
  71. #------------------------------------------------------------------------------
  72. # mwutil::generateEvent
  73. #
  74. # This procedure generates the given event for the mega-widget of the specified
  75. # class containing the widget w if that mega-widget is not the only widget
  76. # receiving the focus during keyboard traversal within its top-level widget.
  77. #------------------------------------------------------------------------------
  78. proc mwutil::generateEvent {w class event} {
  79.     while {[string compare [winfo class $w] $class] != 0} {
  80.     set w [winfo parent $w]
  81.     }
  82.  
  83.     if {[string compare [tk_focusNext $w] $w] != 0} {
  84.     focus $w                ;# necessary on Windows
  85.     event generate $w $event
  86.     }
  87.  
  88.     return -code break ""
  89. }
  90.  
  91. #------------------------------------------------------------------------------
  92. # mwutil::configure
  93. #
  94. # Configures the widget win by processing the command-line arguments specified
  95. # in optValPairs and, if the value of initialize is true, also those database
  96. # options that don't match any command-line arguments.
  97. #------------------------------------------------------------------------------
  98. proc mwutil::configure {win configSpecsName configValsName \
  99.             configCmd optValPairs initialize} {
  100.     upvar $configSpecsName configSpecs
  101.     upvar $configValsName configVals
  102.  
  103.     #
  104.     # Process the command-line arguments
  105.     #
  106.     set cmdLineOpts {}
  107.     set savedVals {}
  108.     set failed 0
  109.     set count [llength $optValPairs]
  110.     foreach {opt val} $optValPairs {
  111.     if {[catch {fullConfigOpt $opt configSpecs} result] != 0} {
  112.         set failed 1
  113.         break
  114.     }
  115.     if {$count == 1} {
  116.         set result "value for \"$opt\" missing"
  117.         set failed 1
  118.         break
  119.     }
  120.     set opt $result
  121.     lappend cmdLineOpts $opt
  122.     lappend savedVals $configVals($opt)
  123.     if {[catch {eval $configCmd [list $win $opt $val]} result] != 0} {
  124.         set failed 1
  125.         break
  126.     }
  127.     incr count -2
  128.     }
  129.  
  130.     if {$failed} {
  131.     #
  132.     # Restore the saved values
  133.     #
  134.     foreach opt $cmdLineOpts val $savedVals {
  135.         eval $configCmd [list $win $opt $val]
  136.     }
  137.  
  138.     return -code error $result
  139.     }
  140.  
  141.     if {$initialize} {
  142.     #
  143.     # Process those configuration options that were not
  144.     # given as command-line arguments; use the corresponding
  145.     # values from the option database if available
  146.     #
  147.     foreach opt [lsort [array names configSpecs]] {
  148.         if {[llength $configSpecs($opt)] == 1 ||
  149.         [lsearch -exact $cmdLineOpts $opt] >= 0} {
  150.         continue
  151.         }
  152.         set dbName [lindex $configSpecs($opt) 0]
  153.         set dbClass [lindex $configSpecs($opt) 1]
  154.         set dbValue [option get $win $dbName $dbClass]
  155.         if {[string compare $dbValue ""] != 0} {
  156.         if {[catch {
  157.             eval $configCmd [list $win $opt $dbValue]
  158.         } result] != 0} {
  159.             return -code error $result
  160.         }
  161.         } else {
  162.         set default [lindex $configSpecs($opt) 3]
  163.         eval $configCmd [list $win $opt $default]
  164.         }
  165.     }
  166.     }
  167.  
  168.     return ""
  169. }
  170.  
  171. #------------------------------------------------------------------------------
  172. # mwutil::fullConfigOpt
  173. #
  174. # Returns the full configuration option corresponding to the possibly
  175. # abbreviated option opt.
  176. #------------------------------------------------------------------------------
  177. proc mwutil::fullConfigOpt {opt configSpecsName} {
  178.     upvar $configSpecsName configSpecs
  179.  
  180.     if {[info exists configSpecs($opt)]} {
  181.     if {[llength $configSpecs($opt)] == 1} {
  182.         return $configSpecs($opt)
  183.     } else {
  184.         return $opt
  185.     }
  186.     }
  187.  
  188.     set optList [lsort [array names configSpecs]]
  189.     set count 0
  190.     foreach elem $optList {
  191.     if {[string first $opt $elem] == 0} {
  192.         incr count
  193.         if {$count == 1} {
  194.         set option $elem
  195.         } else {
  196.         break
  197.         }
  198.     }
  199.     }
  200.  
  201.     switch $count {
  202.     0 {
  203.         ### return -code error "unknown option \"$opt\""
  204.         return -code error \
  205.            "bad option \"$opt\": must be [enumOpts $optList]"
  206.     }
  207.  
  208.     1 {
  209.         if {[llength $configSpecs($option)] == 1} {
  210.         return $configSpecs($option)
  211.         } else {
  212.         return $option
  213.         }
  214.     }
  215.  
  216.     default {
  217.         ### return -code error "unknown option \"$opt\""
  218.         return -code error \
  219.            "ambiguous option \"$opt\": must be [enumOpts $optList]"
  220.     }
  221.     }
  222. }
  223.  
  224. #------------------------------------------------------------------------------
  225. # mwutil::fullOpt
  226. #
  227. # Returns the full option corresponding to the possibly abbreviated option opt.
  228. #------------------------------------------------------------------------------
  229. proc mwutil::fullOpt {kind opt optList} {
  230.     if {[lsearch -exact $optList $opt] >= 0} {
  231.     return $opt
  232.     }
  233.  
  234.     set count 0
  235.     foreach elem $optList {
  236.     if {[string first $opt $elem] == 0} {
  237.         incr count
  238.         if {$count == 1} {
  239.         set option $elem
  240.         } else {
  241.         break
  242.         }
  243.     }
  244.     }
  245.  
  246.     switch $count {
  247.     0 {
  248.         return -code error \
  249.            "bad $kind \"$opt\": must be [enumOpts $optList]"
  250.     }
  251.  
  252.     1 {
  253.         return $option
  254.     }
  255.  
  256.     default {
  257.         return -code error \
  258.            "ambiguous $kind \"$opt\": must be [enumOpts $optList]"
  259.     }
  260.     }
  261. }
  262.  
  263. #------------------------------------------------------------------------------
  264. # mwutil::enumOpts
  265. #
  266. # Returns a string consisting of the elements of the given list, separated by
  267. # commas and spaces.
  268. #------------------------------------------------------------------------------
  269. proc mwutil::enumOpts optList {
  270.     set optCount [llength $optList]
  271.     set n 1
  272.     foreach opt $optList {
  273.     if {$n == 1} {
  274.         set str $opt
  275.     } elseif {$n < $optCount} {
  276.         append str ", $opt"
  277.     } else {
  278.         if {$optCount > 2} {
  279.         append str ","
  280.         }
  281.         append str " or $opt"
  282.     }
  283.  
  284.     incr n
  285.     }
  286.  
  287.     return $str
  288. }
  289.  
  290. #------------------------------------------------------------------------------
  291. # mwutil::setConfigVals
  292. #
  293. # Sets the elements of the array specified by configValsName to the values
  294. # returned by passing the widget name win and the relevant options to the
  295. # command given by cgetCmd.
  296. #------------------------------------------------------------------------------
  297. proc mwutil::setConfigVals {win configSpecsName configValsName
  298.                 cgetCmd argList} {
  299.     upvar $configSpecsName configSpecs
  300.     upvar $configValsName configVals
  301.  
  302.     set optList {}
  303.     if {[llength $argList] == 0} {
  304.     foreach opt [array names configSpecs] {
  305.         if {[llength $configSpecs($opt)] > 1} {
  306.         lappend optList $opt
  307.         }
  308.     }
  309.     } else {
  310.     foreach {opt val} $argList {
  311.         lappend optList [fullConfigOpt $opt configSpecs]
  312.     }
  313.     }
  314.  
  315.     foreach opt $optList {
  316.     set configVals($opt) [eval $cgetCmd [list $win $opt]]
  317.     }
  318. }
  319.  
  320. #------------------------------------------------------------------------------
  321. # mwutil::configSubCmd
  322. #
  323. # This procedure is invoked to process configuration subcommands.
  324. #------------------------------------------------------------------------------
  325. proc mwutil::configSubCmd {win configSpecsName configValsName
  326.                configCmd argList} {
  327.     upvar $configSpecsName configSpecs
  328.     upvar $configValsName configVals
  329.  
  330.     switch [llength $argList] {
  331.     0 {
  332.         #
  333.         # Return a list describing all available configuration options
  334.         #
  335.         foreach opt [lsort [array names configSpecs]] {
  336.         if {[llength $configSpecs($opt)] == 1} {
  337.             set alias $configSpecs($opt)
  338.             if {$::tk_version < 8.1} {
  339.             set dbName [lindex $configSpecs($alias) 0]
  340.             lappend result [list $opt $dbName]
  341.             } else {
  342.             lappend result [list $opt $alias]
  343.             }
  344.         } else {
  345.             set dbName [lindex $configSpecs($opt) 0]
  346.             set dbClass [lindex $configSpecs($opt) 1]
  347.             set default [lindex $configSpecs($opt) 3]
  348.             lappend result [list $opt $dbName $dbClass $default \
  349.                     $configVals($opt)]
  350.         }
  351.         }
  352.         return $result
  353.     }
  354.  
  355.     1 {
  356.         #
  357.         # Return the description of the specified configuration option
  358.         #
  359.         set opt [fullConfigOpt [lindex $argList 0] configSpecs]
  360.         set dbName [lindex $configSpecs($opt) 0]
  361.         set dbClass [lindex $configSpecs($opt) 1]
  362.         set default [lindex $configSpecs($opt) 3]
  363.         return [list $opt $dbName $dbClass $default $configVals($opt)]
  364.     }
  365.  
  366.     default {
  367.         #
  368.         # Set the specified configuration options to the given values
  369.         #
  370.         return [configure $win configSpecs configVals $configCmd $argList 0]
  371.     }
  372.     }
  373. }
  374.  
  375. #------------------------------------------------------------------------------
  376. # mwutil::attribSubCmd
  377. #
  378. # This procedure is invoked to process the attrib subcommand.
  379. #------------------------------------------------------------------------------
  380. proc mwutil::attribSubCmd {win argList} {
  381.     set classNs [string tolower [winfo class $win]]
  382.     upvar ::${classNs}::ns${win}::attribVals attribVals
  383.  
  384.     set argCount [llength $argList]
  385.     switch $argCount {
  386.     0 {
  387.         #
  388.         # Return the current list of attribute names and values
  389.         #
  390.         set result {}
  391.         foreach attr [lsort [array names attribVals]] {
  392.         lappend result [list $attr $attribVals($attr)]
  393.         }
  394.         return $result
  395.     }
  396.  
  397.     1 {
  398.         #
  399.         # Return the value of the specified attribute
  400.         #
  401.         set attr [lindex $argList 0]
  402.         if {[info exists attribVals($attr)]} {
  403.         return $attribVals($attr)
  404.         } else {
  405.         return ""
  406.         }
  407.     }
  408.  
  409.     default {
  410.         #
  411.         # Set the specified attributes to the given values
  412.         #
  413.         if {$argCount % 2 != 0} {
  414.         return -code error "value for \"[lindex $argList end]\" missing"
  415.         }
  416.         array set attribVals $argList
  417.         return ""
  418.     }
  419.     }
  420. }
  421.